home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / Pascal / Applications / DropBin 1.5 / BinHex.p next >
Encoding:
Text File  |  1997-04-16  |  10.3 KB  |  445 lines  |  [TEXT/CWIE]
  1. Unit Binhex;
  2. {$NR+}
  3.  
  4. Interface
  5.  
  6. Uses
  7.     Toolbox, DropBinUtils, BinProgress;
  8.     
  9. Const
  10.     BinHexOpen = 5807;
  11.     BufferSize = 4096;
  12.     MemErr = 6417;
  13.     BinHexRead = 5811;
  14.     BinHexTable = '!"#$%&''()*+,-012345689@ABCDEFGHIJKLMNPQRSTUVXYZ[`abcdefhijklmpqr';
  15.     BinHexHeader = '(This file must be converted with BinHex 4.0)';
  16.  
  17. Var
  18.     DontTranslate:    Boolean;    { don't use translation tables }
  19.     CommandPeriod:    Boolean;    { has cmd-. been pressed lately? }
  20.     State86:        SignedByte;
  21.     SavedBits:        SignedByte;
  22.     LineLength:        SignedByte;
  23.  
  24. Function BinHexFile(vRef: integer; dirId: longint; name: str255): integer;
  25.  
  26. Implementation
  27.  
  28. {************************************************************************
  29.  * EncodeDataChar - encode an 8-bit data char into a six-bit buffer
  30.  * returns the number of valid encoded characters generated
  31.  ************************************************************************}
  32. Function EncodeDataChar(c: SignedByte; toSpot: Ptr): integer;
  33.  
  34. Var
  35.     spotWas:        Ptr;
  36.     
  37. Procedure Addnewline;
  38.  
  39.     begin
  40.     linelength := 0;
  41.     toSpot^ := kReturnKey;
  42.     OffsetPtr(toSpot,1);
  43.     end;
  44.     
  45. Var
  46.     i:    integer;
  47.             
  48.     begin
  49.     spotWas := toSpot;
  50.     case State86 of
  51.         0:    begin
  52.             i := BAnd(BSR(c,2),$3F);
  53.             toSpot^ := SignedByte(BinHexTable[i+1]);
  54.             OffsetPtr(toSpot, 1);
  55.             SavedBits := BSL(BAnd(c,$03),4);
  56.             inc(lineLength);
  57.             if lineLength = 64 then
  58.                 Addnewline;
  59.             end;
  60.         1:    begin
  61.             i := BOr(SavedBits,BAnd(BSR(c,4),$0F));
  62.             toSpot^ := SignedByte(BinHexTable[i+1]);
  63.             OffsetPtr(toSpot, 1);
  64.             SavedBits := BSL(BAnd(c,$0f),2);
  65.             inc(lineLength);
  66.             if lineLength = 64 then
  67.                 Addnewline;
  68.             end;
  69.         2:    begin
  70.             i := BOr(SavedBits,BAnd(BSR(c,6),$03));
  71.             toSpot^ := SignedByte(BinHexTable[i+1]);
  72.             OffsetPtr(toSpot, 1);
  73.             inc(lineLength);
  74.             if lineLength = 64 then
  75.                 Addnewline;
  76.             i := BAnd(c,$3f);
  77.             toSpot^ := SignedByte(BinHexTable[i+1]);
  78.             OffsetPtr(toSpot, 1);
  79.             inc(lineLength);
  80.             if lineLength = 64 then
  81.                 Addnewline;
  82.             State86 := -1;
  83.             end;
  84.         end; { of CASE }
  85.     inc(State86);
  86.     EncodeDataChar := ORD4(toSpot) - ORD4(spotWas);
  87.     end; 
  88.  
  89. Procedure CalcCRC(c: unsignedWord);
  90.  
  91. Const
  92.     ByteMask    =    $0FF;
  93.     WordMask    =    $0FFFF;
  94.     WordBit        =    $10000;
  95.     CrcConstant    =    $01021;
  96.  
  97. Var
  98.     i:    integer;
  99.  
  100.     begin
  101.     c := BAnd(c, ByteMask);
  102.     for i := 1 to 8 do
  103.         begin
  104.         c := BSL(c,1);
  105.         mainCRC := BSL(mainCRC,1);
  106.         if BAnd(mainCRC,WordBit) <> 0 then
  107.             mainCRC := BXOr(BAnd(mainCRC,WordMask), CrcConstant);
  108.         mainCRC := BXOr(mainCRC,BSR(c,8));
  109.         c := BAnd(c, ByteMask);
  110.         end;
  111.     end;
  112.  
  113. Procedure Code(dc: SignedByte; var codedSpot: integer; codedBuffer: Ptr);
  114.  
  115.     Procedure LCode(dc: SignedByte);
  116.  
  117.         begin
  118.         codedSpot := codedSpot + 
  119.             EncodeDataChar(dc,Ptr(ORD4(codedBuffer) + codedSpot));
  120.         end;
  121.         
  122.     begin
  123.     LCode(dc);
  124.     if dc = -112 then
  125.         LCode(0);
  126.     CalcCRC(dc);
  127.     end;
  128.     
  129. Procedure CodeShort(ds: integer; var codedSpot: integer; codedBuffer: Ptr);
  130.  
  131. Var
  132.     cp:        Ptr;
  133.     
  134.     begin
  135.     cp := @ds;
  136.     Code(cp^, codedSpot, codedBuffer);
  137.     Code(AddPtrLong(cp,1)^, codedSpot, codedBuffer);
  138.     end;
  139.     
  140. Procedure CodeShortInt(ds: integer; var codedSpot: integer; codedBuffer: Ptr);
  141.  
  142. Var
  143.     cp:        Ptr;
  144.     
  145.     begin
  146.     cp := @ds;
  147.     Code(AddPtrLong(cp,1)^, codedSpot, codedBuffer);
  148.     Code(cp^, codedSpot, codedBuffer);
  149.     end;
  150.     
  151. Procedure CodeLong(dl: longint; var codedSpot: integer; codedBuffer: Ptr);
  152.  
  153. Var
  154.     copy:    longint;
  155.     cp:        Ptr;
  156.  
  157.     begin
  158.     copy := dl;
  159.     cp := @dl;
  160.     Code(cp^, codedSpot, codedBuffer);
  161.     Code(AddPtrLong(cp,1)^, codedSpot, codedBuffer);
  162.     Code(AddPtrLong(cp,2)^, codedSpot, codedBuffer);
  163.     Code(AddPtrLong(cp,3)^, codedSpot, codedBuffer);
  164.     end;
  165.     
  166. Function WriteBuffer(buffptr: univ Ptr; buffsize: longint): integer;
  167.  
  168.     begin
  169.     WriteBuffer := FSWrite(gRefNum, buffsize, buffptr);
  170.     end;
  171.  
  172. Procedure WriteZero(pointer: Ptr; size: longint);
  173.  
  174.     begin
  175.     while size > 0 do
  176.         begin
  177.         pointer^ := 0;
  178.         OffsetPtr(pointer,1);
  179.         dec(size);
  180.         end;
  181.     end;
  182.  
  183. Function DeleteFile(name: str255; vRefN: integer; dirId: longint): integer;
  184.  
  185. Var
  186.     pb:            HParamBlockRec;
  187.     
  188.     begin
  189.     if FSClose(gRefNum) = 0 then;
  190.     pb.ioNamePtr := @name;
  191.     pb.ioVRefNum := vRefN;
  192.     pb.ioMisc := nil;
  193.     HFileParamPtr(@pb)^.ioDirID := dirID;
  194.     DeleteFile := PBHDeleteSync(@pb);
  195.     end;
  196.     
  197. Function FSHOpen(name: str255; vRefN: integer; dirId: longint; 
  198.                  var refN: integer; perm: integer): integer;
  199.  
  200. Var
  201.     pb:            HParamBlockRec{HIOParam};
  202.     err:        integer;
  203.     
  204.     begin
  205.     pb.ioNamePtr := @name;
  206.     pb.ioVRefNum := vRefN;
  207.     pb.ioPermssn := perm;
  208.     pb.ioMisc := nil;
  209.     HFileParamPtr(@pb)^.ioDirID := dirID;
  210.     err := PBHOpenSync(@pb);
  211.     if err = noErr then
  212.         refN := pb.ioRefNum;
  213.     FSHOpen := err;
  214.     end;
  215.  
  216. Function RFHOpen(name: Str255; vRefN: integer; dirId: longint; 
  217.                  var refN: integer; perm: integer): integer;
  218.  
  219. Var
  220.     pb:        HParamBlockRec;
  221.     err:    integer;
  222.     
  223.     begin
  224.     pb.ioCompletion := nil;
  225.     pb.ioNamePtr := @name;
  226.     pb.ioVRefNum := vRefN;
  227.     pb.ioVersNum := 0;
  228.     pb.ioPermssn := perm;
  229.     pb.ioMisc := nil;
  230.     HFileParamPtr(@pb)^.ioDirID := dirID;
  231.     err := PBHOpenRFSync(@pb);
  232.     if err = noErr then
  233.         refN := pb.ioRefNum;
  234.     RFHOpen := err;
  235.     end;
  236.  
  237. Function HGetFileInfo(vRef: integer; dirId: longint; name: str255; var hfi: HFileParam): integer;
  238.  
  239. Var
  240.     oe:        integer;
  241.  
  242.     begin
  243.     WriteZero(@hfi,sizeof(hfi));
  244.     hfi.ioNamePtr := @name;
  245.     hfi.ioVRefNum := vRef;
  246.     hfi.ioDirID := dirID;
  247.     oe := PBHGetFInfoSync(@hfi);
  248.     HGetFileInfo := oe;
  249.     end;
  250.  
  251. Function AddCRC(var idx:    integer; codedBuffer: Ptr): OSErr;
  252.  
  253. Var
  254.     tempCrc:    integer;
  255.  
  256.     begin
  257.     CalcCRC(0);
  258.     CalcCRC(0);
  259.     tempCrc := BAnd(mainCRC, $FFFF);
  260.     CodeShort(tempCrc, idx, codedBuffer);
  261.     mainCRC := 0;
  262.     AddCRC := WriteBuffer(codedBuffer, idx);
  263.     end;
  264.         
  265. {************************************************************************
  266.  * BinHexFork - send one fork of a file as BinHex data                                
  267.  ************************************************************************}
  268. Function BinHexFork(refN: integer; dataBuffer: Ptr; dataSize: integer;
  269.                     codedBuffer: Ptr; name: Str255): integer;
  270.  
  271. Var
  272.     dataEnd:     longint;
  273.     bindex:        integer;
  274.     err:        OSErr;
  275.     spot:        Ptr;
  276.     errWas:        OSErr;
  277.     
  278.     begin
  279.     bindex := 0;
  280.     repeat
  281.         dataEnd := dataSize;
  282.         err := FSRead(refN, dataEnd, dataBuffer);
  283.         if (err = noErr) or (err = eofErr) then
  284.             begin
  285.             errWas := err;
  286.             spot := dataBuffer;
  287.             while ORD4(spot) < ORD4(dataBuffer) + dataEnd do
  288.                 begin
  289.                 Code(spot^, bindex, codedBuffer);
  290.                 OffsetPtr(spot, 1);
  291.                 end;
  292.             err := WriteBuffer(codedBuffer, bindex);
  293.             bindex := 0;
  294.             if err = noErr then 
  295.                 err := errWas;
  296.             if UpdateProgress(dataEnd) <> 0 then
  297.                 begin
  298.                 DisplayMsg('Binhex operation cancelled on file "'+gFilename+'".');
  299.                 BinHexFork := -1;
  300.                 exit(BinHexFork);
  301.                 end;
  302.             end;
  303.         if (err <> noErr) and (err <> eofErr) and (not CommandPeriod) then
  304.             AlertUser(name,err);
  305.     until err <> noErr;
  306.     if err = eofErr then
  307.         err := addCRC(bindex, codedBuffer);
  308.     if err = eofErr then
  309.         BinHexFork := noErr
  310.     else
  311.         BinHexFork := err;
  312.     end; { of BinHexFork }
  313.  
  314. {************************************************************************
  315.  * BinHexFile - convert a file to BinHex data                                
  316.  ************************************************************************}
  317. Function BinHexFile(vRef: integer; dirId: longint; name: str255): integer;
  318.  
  319. Var
  320.     refN:            integer;
  321.     dataBuffer:        Ptr;
  322.     codedBuffer:    Ptr;
  323.     dataSize,
  324.     codedSize:        longint;
  325.     i,codedSpot:    integer;
  326.     err:            OSErr;
  327.     hfp:            HFileParam;
  328.     scratch:        Str255;
  329.     
  330.     Procedure ExitBinHex(e: integer);
  331.  
  332.         begin
  333.         if refN <> 0 then
  334.             if FSClose(refN) = 0 then;
  335.         if dataBuffer <> NIL then 
  336.             DisposePtr(Ptr(dataBuffer));
  337.         if codedBuffer <> NIL then 
  338.             DisposePtr(Ptr(codedBuffer));
  339.         gProcessing := false;
  340.         InvalRect(dbWindow^.portRect);
  341.         DontTranslate := False;
  342.         if e <> noErr then
  343.             begin
  344.             e := DeleteFile(gOutputName, vRef, dirId);    
  345.             if e <> noErr then
  346.                 AlertUser('Error deleting file ' + gOutputName, e);
  347.             EndProgress;
  348.             ResetWindow(dbWindow);
  349.             end
  350.         else
  351.             EndProgress;
  352.         BinHexFile := e;
  353.         exit(BinHexFile);
  354.         end; { of ExitBinHex }
  355.  
  356.     Procedure FailError(msg: str255; e: integer);
  357.  
  358.         begin
  359.         AlertUser(msg, e);
  360.         ExitBinHex(e);
  361.         end; { of FailError }
  362.         
  363.     begin
  364.     if gState then
  365.         begin
  366.         SetupProgress;
  367.         gState := false;
  368.         end;
  369.     gProcessing := true;
  370.     gFilename := name;
  371.     refN := 0;
  372.     dataBuffer := NIL;
  373.     codedBuffer := NIL;
  374.     err := HGetFileInfo(vRef,dirId,name,hfp);
  375.     if err <> noErr then
  376.         FailError('Error reading file header for ' + name, err);  { file error }
  377.     { allocate the buffers }
  378.     codedSize := 4096;
  379.     dataSize := codedSize div 3;
  380.     dataBuffer := NewPtrClear(datasize);
  381.     codedBuffer := NewPtrClear(codedsize);
  382.     if (dataBuffer = NIL) or (codedBuffer = NIL) then
  383.         FailError('Not enough memory', -108);  { Memory error }
  384.     StartProgress(hfp.ioFlLgLen+hfp.ioFlRLgLen);
  385.     { set the header }
  386.     scratch := chr(13) + BinHexHeader + chr(13) + chr(13) + ':';
  387.     err := WriteBuffer(@scratch[1], integer(scratch[0]));
  388.     if err <> noErr then
  389.         FailError('Error writing header', err);  { Header error }
  390.     { set the file information }
  391.     DontTranslate := True;
  392.     LineLength := 1;
  393.     State86 := 0;
  394.     mainCRC := 0;
  395.     codedSpot := 0;
  396.     for i := 0 to length(name) do
  397.         Code(byte(name[i]), codedSpot, codedBuffer);
  398.     Code(0, codedSpot, codedBuffer);
  399.     CodeLong(longint(hfp.ioFlFndrInfo.fdType), codedSpot, codedBuffer);
  400.     CodeLong(longint(hfp.ioFlFndrInfo.fdCreator), codedSpot, codedBuffer);
  401.     CodeShort(integer(hfp.ioFlFndrInfo.fdFlags), codedSpot, codedBuffer);
  402.     CodeLong(longint(hfp.ioFlLgLen), codedSpot, codedBuffer);
  403.     CodeLong(longint(hfp.ioFlRLgLen), codedSpot, codedBuffer);
  404.     err := addCRC(codedSpot, codedBuffer);
  405.     if err <> noErr then
  406.         FailError('Error calculating CRC for header', err);
  407.     { data fork }
  408.     codedSpot := 0;
  409.     if vRef = 0 then
  410.         FailError('Invalid value for volume reference',-1);
  411.     err := FSHOpen(name,vRef,dirId,refN,fsRdPerm);
  412.     if err <> noErr then
  413.         FailError('Error opening data fork', err);
  414.     err := BinHexFork(refN, dataBuffer, dataSize, codedBuffer, name);
  415.     if err = -1 then
  416.         ExitBinHex(err)
  417.     else if err <> noErr then 
  418.         FailError('Error encoding data fork',err);
  419.     { resource fork }
  420.     codedSpot := 0;
  421.     if refN <> 0 then
  422.          FSClose(refN);
  423.     refN := 0;
  424.     err := RFHOpen(name,vRef,dirId,refN,fsRdPerm);
  425.     if err <> noErr then
  426.         FailError('Error opening resource fork', err);
  427.     err := BinHexFork(refN, dataBuffer, dataSize, codedBuffer, name);
  428.     if err = -1 then
  429.         ExitBinHex(err)
  430.     else if err <> noErr then 
  431.         FailError('Error encoding resource fork', err);
  432.     { leftovers }
  433.     if State86 <> 0 then 
  434.         Code(0, codedSpot, codedBuffer);
  435.     PtrUpdate(codedBuffer,codedSpot,':');
  436.     inc(codedSpot);
  437.     PtrUpdate(codedBuffer,codedSpot,chr(13));
  438.     inc(codedSpot);
  439.     err := WriteBuffer(codedBuffer,codedSpot);
  440.     if err <> noErr then 
  441.         FailError('Error completing binhex encoding', err);
  442.     ExitBinHex(noErr);
  443.     end;
  444.     
  445. End.